home *** CD-ROM | disk | FTP | other *** search
- \ GEM VDI bindings
-
- \ Written by Jesse Taylor.
-
- \ These bindings try to conform to the bindings that are outlined in the
- \ digital research gem vdi manual. The bindings that are outlined in the
- \ VDI manual are written in the 'C' programming language. Although FORTH is
- \ similar to 'C', there are some things that FORTH does different from 'C'.
- \ As a consequence there are some small differences between the 'C' and the
- \ FORTH VDI bindings. These differences are pointed out where they exist.
-
- \ Control Functions
-
- : open-station ( work_in[11], &handle, work_out[57] -- )
- 11 #intin! #ptsinoff
- vdi-block 2dup swap 90 + swap 16 + ! 12 + !
- swap vdi-block 4+ ! callvdi
- 6 contrl@ swap ! intin-buf !pba-intin ptsin-buf !pba-ptsin
- ;
- : v_opnwk ( work_in[11], &handle, work_out[57] -- )
- 1 set-op open-station
- ;
- : v_clswk ( handle -- )
- 2 set-op 6 contrl! callvdi
- ;
- : v_opnvwk ( work_in[11], &handle, work_out[57] -- )
- 100 set-op open-station
- ;
- : v_clsvwk ( handle -- )
- 2 set-op #dev! callvdi
- ;
- : v_clrwk ( handle -- )
- #dev! #pt-intinoff 3 set-op callvdi
- ;
- : v_updwk ( handle -- )
- 4 set-op #pt-intinoff #dev! callvdi
- ;
- : vst_load_fonts ( handle select -- additional )
- 119 set-op #ptsinoff 1 #intin! 0 intin! #dev! callvdi 0 intout@
- ;
- : vst_unload_fonts ( handle select -- )
- 120 set-op #ptsinoff 1 #intin! 0 intin! #dev! callvdi
- ;
- : vs_clip ( handle clip_flag pxyarray -- )
- 129 set-op 1 #intin! 2 #ptsin! !pba-ptsin 0 intin! #dev! callvdi
- ptsin-buf !pba-ptsin
- ;
-
- \ Output Functions
-
- : v_pline ( handle count pxyarray -- )
- 6 set-op #intinoff !pba-ptsin #ptsin! #dev! callvdi
- ptsin-buf !pba-ptsin
- ;
- : v_pmarker ( handle count pxyarray -- )
- 7 set-op #intinoff !pba-ptsin #dev! callvdi ptsin-buf !pba-ptsin
- ;
- : v_gtext ( handle x y string -- )
- \ !!! WARNING !!! the string parameter in this routine is a Forth string
- \ not a 'C' string. This means that this is a string that contains a leading
- \ length byte. A 'C' string has no length byte, but it is null terminated.
- \ You do not need to put a null character at the end of your string.
-
- count dup 1+ #intin! tuck 0
- do dup i + c@ i intin! 1+ loop
- drop 1+ 0 swap intin!
- 8 set-op 1 #ptsin! 0 ptsin! #dev! callvdi
- ;
- : v_fillarea ( handle count pxyarray -- )
- 9 set-op #intinoff !pba-ptsin #ptsin! #dev! callvdi ptsin-buf !pba-ptsin
- ;
- : v_cellarray ( handle, pxyarray, row_length, el_used, num_rows, wrt_mode,
- colarray celarray_length )
- \ !!! WARNING !!! This routine had to be modified. The last input value is a
- \ new addition to the cellarray routine. It is the length of the
- \ color index array in words
- 10 set-op #intin! !pba-intin 10 contrl! 9 contrl! 8 contrl! 7 contrl!
- !pba-ptsin 2 #ptsin! #dev! callvdi
- intin-buf !pba-intin ptsin-buf !pba-ptsin
- ;
- : v_contourfill ( handle, x, y, index )
- 103 set-op 1 #intin! 1 #ptsin! 0 intin! 0 ptsin! #dev! callvdi
- ;
- : vr_recfl ( handle, pxarray )
- 114 set-op 2 #ptsin! 0 #intin! !pba-ptsin #dev! callvdi
- ptsin-buf !pba-ptsin
- ;
- : v_bar ( handle, pxarray )
- 11 set-op !pba-ptsin #dev! 1 5 contrl! 2 #ptsin! #intinoff callvdi
- ptsin-buf !pba-ptsin
- ;
- : v_arc ( handle, x, y, radius, begang, endang )
- 11 set-op 4 #ptsin! 2 #intin! 2 5 contrl!
- 1 intin! 0 intin! 6 ptsin[] w! 0 ptsin! #dev! 0 0 2dup 2 ptsin!
- 4 ptsin! callvdi
- ;
- : v_pieslice ( handle, x, y, radius, begang, endang )
- 11 set-op 4 #ptsin! 2 #intin! 3 5 contrl!
- 1 intin! 0 intin! 6 ptsin[] w! 0 ptsin! #dev! 0 0 2dup 2 ptsin!
- 4 ptsin! 0 7 ptsin[] w! callvdi
- ;
- : v_circle ( handle, x, y, radius )
- 11 set-op #intinoff 3 #ptsin! 4 5 contrl! 4 ptsin[] w! 0 ptsin!
- 0 0 2 ptsin! 0 5 ptsin[] w! #dev! callvdi
- ;
- : v_ellarc ( handle, x, y, xradius, yradius, begang, endang )
- 11 set-op 2 #ptsin! 2 #intin! 6 5 contrl!
- 1 intin! 0 intin! 2 ptsin! 0 ptsin! #dev! callvdi
- ;
- : v_ellpie ( handle, x, y, xradius, yradius, begang, endang )
- 11 set-op 2 #ptsin! 2 #intin! 7 5 contrl!
- 1 intin! 0 intin! 2 ptsin! 0 ptsin! #dev! callvdi
- ;
- : v_ellipse ( handle, x, y, xradius, yradius )
- 11 set-op 2 #ptsin! #intinoff 5 5 contrl! 2 ptsin! 0 ptsin! #dev!
- callvdi
- ;
- : v_rbox ( handle, xyarray )
- 11 set-op 8 5 contrl! 2 #ptsin! 0 #intin! !pba-ptsin #dev! callvdi
- ptsin-buf !pba-ptsin
- ;
- : v_rfbox ( handle, xyarray )
- 11 set-op 9 5 contrl! 2 #ptsin! 0 #intin! !pba-ptsin #dev! callvdi
- ptsin-buf !pba-ptsin
- ;
- : v_justified ( handle, x, y, string, length, word_space, char_space )
- \ !!! WARNING !!! the string parameter in this routine is a forth string
- \ not a 'C' string. This means that this is a string that contains a leading
- \ length byte. A 'C' string has no length byte, but it is null terminated.
- \ You do not need to put a null character at the end of your string.
-
- 11 set-op 10 5 contrl! 2 #ptsin! 1 intin! 0 intin! 0 2 ptsin!
- count dup 3 + #intin! tuck 0
- do dup i + c@ i 2+ intin! 1+ loop drop 3 + 0 swap intin!
- 0 ptsin! #dev! callvdi
- ;
-
- \ Attribute Functions
-
- : set-one ( handle, value, op# -- actual_value_selected )
- set-op #ptsinoff 1 #intin! 0 intin! #dev! callvdi 0 intout@
- ;
- : vswr_mode ( handle, mode -- mode_selected )
- 32 set-one
- ;
- : vs_color ( handle, index, rgb_in )
- 14 set-op #ptsinoff 4 #intin!
- dup w@ 1 intin!
- dup 2+ w@ 2 intin!
- dup 4+ w@ 3 intin!
- 0 intin!
- #dev! callvdi
- ;
- : vsl_type ( handle, style -- type_actualy_set )
- 15 set-one
- ;
- : vsl_udsty ( handle, pattern )
- 113 set-op #ptsinoff 1 #intin! 0 intin! #dev! callvdi
- ;
- : vsl_width ( handle, width -- width_actualy_set )
- 16 set-op 1 #ptsin! #intinoff 0 0 ptsin! #dev! callvdi 0 ptsout[] w@
- ;
- : vsl_color ( handle, color_index -- color_actualy_set )
- 17 set-one
- ;
- : vsl_ends ( handle, beg_style, end_style )
- 108 set-op #ptsinoff 2 #intin! 1 intin! 0 intin! #dev! callvdi
- ;
- : vsm_type ( handle, style -- type_actualy_set )
- 18 set-one
- ;
- : vsm_height ( handle, height -- actual_set_height )
- 19 set-op 1 #ptsin! #intinoff 0 swap 0 ptsin! #dev! callvdi
- 1 ptsout[] w@
- ;
- : vsm_color ( handle, color_index -- actual_color_selected )
- 20 set-one
- ;
- : vsr_height ( handle, height, &char_width, &char_height, &cell_width
- &cell_height )
- 12 set-op 1 #ptsin! #intinoff 0 5 pick 0 ptsin! 5 pick #dev! callvdi
- 3 ptsout[] w@ swap ! 2 ptsout[] w@ swap !
- 1 ptsout[] w@ swap ! 0 ptsout[] w@ swap ! 2drop
- ;
- : vst_point ( handle, point, &char_width, &char_height, &cell_width
- &cell_height )
- 107 set-op 1 #intin! #ptsinoff 4 pick 0 intin! 5 pick #dev! callvdi
- 3 ptsout[] w@ swap ! 2 ptsout[] w@ swap !
- 1 ptsout[] w@ swap ! 0 ptsout[] w@ swap ! 2drop
- ;
- : vst_rotation ( handle, angle -- actual_angle_selected )
- 13 set-one
- ;
- : vst_font ( handle, font -- actual_font_selected )
- 21 set-one
- ;
- : vst_color ( handle, color -- actual_color_selected )
- 22 set-one
- ;
- : vst_effects ( handle, effect -- actual_effect_selected )
- 21 set-one
- ;
- : vst_alignment ( handle, hor_in, vert_in, &hor_out, &vert_out )
- 39 set-op #ptsinoff 2 #intin! 2swap 1 intin! 0 intin! rot #dev! callvdi
- 1 intout@ swap ! 0 intout@ swap !
- ;
- : vsf_interior ( handle, style -- actual_style_selected )
- 23 set-one
- ;
- : vsf_style ( handle, style_index -- actual_style_selected )
- 24 set-one
- ;
- : vsf_color ( handle, color_index -- actual_style_selected )
- 25 set-one
- ;
- : vsf_perimeter ( handle, per_vis -- actual_perimeter_selected )
- 104 set-one
- ;
- : vsf_udpat ( handle, pfill_pat, planes )
- 112 set-op #ptsinoff 16 * #intin! !pba-intin #dev! callvdi
- intin-buf !pba-intin
- ;
-
- \ Raster Operations
-
- : vro_cpyfm ( handle, wr_mode, pxyarray, psrcMFDB, pdesMFDB )
- 109 set-op 4 #ptsin! 1 #intin! 9 contrl[] ! 7 contrl[] ! !pba-ptsin
- 0 intin! #dev! callvdi ptsin-buf !pba-ptsin
- ;
- : vrt_cpyfm ( handle, wr_mode, pxyarray, psrcMFDB, pdesMFDB, color_index[2] )
- 121 set-op 4 #ptsin! 3 #intin! @ 1 ptsin[] !
- 9 contrl[] ! 7 contrl[] ! !pba-ptsin
- 0 intin! #dev! callvdi ptsin-buf !pba-ptsin
- ;
- : vr_trnfm ( handle, psrcMFDB, pdesMFDB )
- 110 set-op #intinoff #ptsinoff 9 contrl[] ! 7 contrl[] ! #dev! callvdi
- ;
- : v_get_pixel ( handle, x, y, *pel, *index )
- 105 set-op 1 #ptsin! #intinoff 2swap 0 ptsin! rot #dev! callvdi
- 1 intout@ swap ! 0 intout@ swap !
- ;
-
- \ Input Functions
-
- : vsin_mode ( handle, dev_type, mode )
- 33 set-op #ptsinoff 2 #intin! 1 intin! 0 intin! #dev! callvdi
- ;
- : vrq_locator ( handle, x, y, &xout, &yout, &term )
- 28 set-op 1 #ptsin! #intinoff 2rot 5 pick 0 ptsin! #dev! callvdi
- 0 intout@ swap ! 1 ptsout[] w@ swap ! 0 ptsout[] w@ swap ! drop
- ;
- : vsm_locator ( handle, x, y, &xout, &yout, &term -- status )
- 28 set-op 1 #ptsin! #intinoff 2rot 5 pick 0 ptsin! #dev! callvdi
- 0 intout@ swap ! 1 ptsout[] w@ swap ! 0 ptsout[] w@ swap ! drop
- 2 contrl@ 0<> 4 contrl@ 0<> or
- ;
- : vrq_valuator ( handle, val_in, &val_out, &term, &status )
- 29 set-op #ptsinoff 1 #intin! 0 2rot 0 intin! #dev! drop callvdi
- 4 contrl@ swap ! 1 intout@ swap ! 0 intout@ swap !
- ;
- : vrq_choice ( handle, ch_in, &ch_out )
- 30 set-op #ptsinoff 1 #intin! -rot 0 intin! #dev! callvdi
- 0 intout@ swap !
- ;
- : vsm_choice ( handle, &choice )
- 30 set-op #ptsinoff #intinoff swap #dev! callvdi
- 0 intout@ swap ! 4 contrl@
- ;
- : vrq_string ( handle, max_length, echo_mode, echo_xy[2], &string )
- 31 set-op 1 #ptsin! 2 #intin! >r @ 0 ptsin[] ! 1 intin! 0 intin!
- #dev! callvdi 4 contrl@ 1- dup r@ c! r> 1+ swap 0
- do i intout@ over c! 1+ loop
- ;
- : vsm_string ( handle, max_length, echo_mode, echo_xy[2], &string -- status )
- 31 set-op 1 #ptsin! 2 #intin! >r @ 0 ptsin[] ! 1 intin! 0 intin!
- #dev! callvdi 4 contrl@ 1- dup r@ c! r> 1+ swap 0
- do i intout@ over c! 1+ loop 4 contrl@
- ;
- : vsc_form ( handle, pcur_form[36] )
- 111 set-op #ptsinoff 37 #intin! !pba-intin #dev! callvdi
- ;
- : vex_timv ( handle, tim_addr, *otim_addr, &tim_conv )
- 118 set-op #intinoff #ptsinoff 2swap 7 contrl[] ! #dev! callvdi
- 0 intout@ swap ! 9 contrl[] @ swap !
- ;
- : v_show_c ( handle, reset )
- 122 set-op #ptsinoff 1 #intin! 0 intin! #dev! callvdi
- ;
- : v_hide_c ( handle )
- 123 set-op #dev! #intinoff #ptsinoff callvdi
- ;
- : vq_mouse ( handle, &pstatus, &x, &y )
- 124 set-op #intinoff #ptsinoff 3 pick #dev! callvdi
- 0 ptsout@ rot ! swap ! 0 intout@ swap ! drop
- ;
- : vex_butv ( handle, *pusrcode, *psavcode, )
- 125 set-op #intinoff #ptsinoff swap 7 contrl[] ! swap #dev! callvdi
- 9 contrl[] @ swap !
- ;
- : vex_motv ( handle, *pusrcode, *psavcode, )
- 126 set-op #intinoff #ptsinoff swap 7 contrl[] ! swap #dev! callvdi
- 9 contrl[] @ swap !
- ;
- : vex_curv ( handle, *pusrcode, *psavcode, )
- 127 set-op #intinoff #ptsinoff swap 7 contrl[] ! swap #dev! callvdi
- 9 contrl[] @ swap !
- ;
- : vq_key_s ( handle, &pstatus )
- 128 set-op #intinoff #ptsinoff swap #dev! callvdi 0 intout@ swap !
- ;
-
- \ Inquire Functions
-
- : vq_extend ( handle, owflag, work_out )
- 102 set-op #ptsinoff 1 #intin! dup !pba-intout 90 + vdi-block 16 + !
- 0 intin! #dev! callvdi ptsout-buf !pba-ptsout intout-buf !pba-intout
- ;
- : vq_color ( handle, color_index, set_flag, rgb[3] )
- 26 set-op #ptsinoff 2 #intin! swap 1 intin! swap 0 intin! swap #dev!
- callvdi 1 intout[] swap 6 cmove
- ;
- : vql_attributes ( handle, attrib[4] )
- 35 set-op #intinoff #ptsinoff swap #dev! callvdi 0 ptsout[] w@
- over 6 + w! intout-buf swap 6 cmove
- ;
- : vqm_attributes ( handle, attrib[4] )
- 36 set-op #intinoff #ptsinoff swap #dev! callvdi 1 ptsout[] w@ over 6 +
- w! intout-buf swap 6 cmove
- ;
- : vqf_attributes ( handle, attrib[4] )
- 37 set-op #intinoff #ptsinoff swap #dev! callvdi intout-buf 2@ rot 2!
- ;
- : vqt_attributes ( handle, attrib[10] )
- 38 set-op #intinoff #ptsinoff swap #dev! callvdi
- dup intout-buf swap 12 cmove ptsout-buf swap 12 + 8 cmove
- ;
- : vqt_extent ( handle, string, extent[8] )
- 116 set-op #ptsinoff swap count dup 1+ dup >r #intin! 0
- do dup c@ i intin! 1+ loop drop
- r> 0 swap intin-buf + c! !pba-ptsout #dev! callvdi
- ptsout-buf !pba-ptsout
- ;
- : vqt_width ( handle, character, &cell_width, &left_delta, &right_delta --
- status )
- 117 set-op #ptsinoff 1 #intin! 0 2rot 0 intin! #dev! callvdi
- drop 4 ptsout[] w@ swap ! 2 ptsout[] w@ swap ! ptsout-buf w@ swap !
- 0 intout@
- ;
- : vqt_name ( handle, element_num, name[32] -- index )
- 130 set-op 1 #intin! #ptsinoff >r 0 intin! #dev! callvdi r>
- 1 intout[] swap 64 cmove 0 intout@
- ;
- : vqt_fontinfo ( handle, &minADE, &maxADE, distances, &maxwidth, effects[3] )
- 131 set-op #intinoff #ptsinoff 5 pick #dev! callvdi
- 2 ptsout[] swap 6 cmove ptsout-buf w@ swap ! 9 1
- do i ptsout[] w@ over w! 2+ 2 +loop drop
- 1 intout@ swap ! 0 intout@ swap ! drop
- ;
- : vq_cellarray ( handle, pxyarray, row_length, num_rows, &el_used, &rows_used
- &status, colarray[n] )
- 27 set-op 2 #ptsin! #intinoff 2rot 8 contrl[] w! 7 contrl[] w!
- 2rot !pba-ptsin #dev! !pba-intout callvdi
- 11 contrl@ swap ! 10 contrl@ swap ! 9 contrl@ swap !
- ptsin-buf !pba-ptsin intout-buf !pba-intout
- ;
- : vqin_mode ( handle, dev_type, &input_mode )
- 115 set-op #ptsinoff 1 #intin! swap 0 intin! swap #dev! callvdi
- 0 intout@ swap !
- ;
-
- \ Escapes
-
- : esc-init ( handle, function# -- )
- 5 set-op 5 contrl[] w! #dev!
- ;
- : vq_chcells ( handle, &rows, &columns )
- rot 1 esc-init callvdi 1 intout@ swap ! 0 intout@ swap !
- ;
- : v_exit_cur ( handle )
- 2 esc-init callvdi
- ;
- : v_enter_cur ( handle )
- 3 esc-init callvdi
- ;
- : v_curup ( handle )
- 4 esc-init callvdi
- ;
- : v_curdown ( handle )
- 5 esc-init callvdi
- ;
- : v_curright ( handle )
- 6 esc-init callvdi
- ;
- : v_curleft ( handle )
- 7 esc-init callvdi
- ;
- : v_curhome ( handle )
- 8 esc-init callvdi
- ;
- : v_eeos ( handle )
- 9 esc-init callvdi
- ;
- : v_eeol ( handle )
- 10 esc-init callvdi
- ;
- : vs_curaddress ( handle, row, collumn )
- rot 11 esc-init 2 #intin! 1 intin! 0 intin! callvdi
- ;
- : v_curtext ( handle &string )
- count dup #intin! 0
- do dup c@ i intin! 1+ loop drop
- #dev! 12 5 contrl[] w! #ptsinoff 5 set-op callvdi
- ;
- : v_rvon ( handle )
- 13 esc-init callvdi
- ;
- : v_rvoff ( handle )
- 14 esc-init callvdi
- ;
- : vq_curaddress ( handle, &row, &column )
- rot 15 esc-init callvdi 1 intout@ swap ! 0 intout@ swap !
- ;
- : vq_tabstatus ( handle -- status )
- 16 esc-init callvdi 0 intout@
- ;
- : v_hardcopy ( handle )
- 17 esc-init callvdi
- ;
- : v_dspcur ( handle x, y )
- rot 18 esc-init 1 #ptsin! 0 ptsin! callvdi
- ;
- : v_rmcur ( handle )
- 19 esc-init callvdi
- ;
- : v_form_adv ( handle )
- 20 esc-init callvdi
- ;
- : v_output_window ( handle, xyarray[4] )
- 5 set-op swap #dev! 21 5 contrl! #intinoff 2 #ptsin! ptsin-buf
- 8 cmove callvdi
- ;
- : v_clear_disp_list ( handle )
- 22 esc-init callvdi
- ;
- : v_bit_image ( handle, filename, aspect, x_scale, y_scale, h_align, y_align,
- xyarray )
- 5 set-op 2 #ptsin! ptsin-buf 8 cmove 4 intin! 3 intin! 2 intin!
- 1 intin! 0 intin! count dup 6 + #intin! 0
- do dup c@ i 5 + intin! 1+ loop drop 3 contrl@ 0 swap intin!
- #dev! callvdi
- ;
- : v_meta_extents ( handle, min_x, min_y, max_x, max_y )
- 5 set-op 98 5 contrl! 2 ptsin! 0 ptsin! #dev! 2 #ptsin! #intinoff
- callvdi
- ;
- : v_write_meta ( handle, num_intin, intin, num_ptsin, ptsin )
- 5 set-op 99 5 contrl!
- !pba-ptsin #ptsin! !pba-intin #intin! #dev! callvdi
- ptsin-buf !pba-ptsin intin-buf !pba-intin
- ;
- : vm_filename ( handle, filename )
- 5 set-op 100 5 contrl! #ptsinoff count dup 1+ dup #intin!
- 0 swap intin! 0
- do dup c@ i intin! 1+ loop drop #dev! callvdi
- ;
-